package Quitz::Core::User;
# $Id: Core.pm 14 2007-02-21 22:56:36Z infected.girl $

use base qw/ DBIx::Class /;

our @ro_columns = qw/ id /;
our @rw_columns = qw/ generic_rights username password /;

__PACKAGE__ -> load_components(qw/ PK::Auto Core /);
__PACKAGE__ -> table('users');
__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);

__PACKAGE__ -> set_primary_key('id');

package Quitz::Core::Category;
use base qw/ DBIx::Class /;

our @ro_columns = qw/ id /;
our @rw_columns = qw/ parent_id owner name /;

__PACKAGE__ -> load_components(qw/ PK::Auto Core /);
__PACKAGE__ -> table('categories');

__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);
__PACKAGE__ -> set_primary_key('id');

package Quitz::Core::Question;
use base qw/ DBIx::Class /;

our @ro_columns = qw/ id /;
our @rw_columns = qw/ category_id content_id weight difficulty is_mutable /;

__PACKAGE__ -> load_components(qw/ PK::Auto Core /);
__PACKAGE__ -> table('questions');

__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);
__PACKAGE__ -> set_primary_key('id');

package Quitz::Core::Answer;
use base qw/ DBIx::Class /;

our @ro_columns = qw/ id /;
our @rw_columns = qw/ question_id content_id is_correct show_order /;

__PACKAGE__ -> load_components(qw/ PK::Auto Core /);
__PACKAGE__ -> table('answers');

__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);
__PACKAGE__ -> set_primary_key('id');

package Quitz::Core::Content;
use base qw/ DBIx::Class /;

our @ro_columns = qw/ id /;
our @rw_columns = qw/ type content /;

__PACKAGE__ -> load_components(qw/ PK::Auto Core /);
__PACKAGE__ -> table('contents');

__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);
__PACKAGE__ -> set_primary_key('id');

package Quitz::Core::ACL;
use base qw/ DBIx::Class /;

our @ro_columns = qw/ /;
our @rw_columns = qw/ user_id category_id access_mask /;

__PACKAGE__ -> load_components(qw/ Core /);
__PACKAGE__ -> table('acls');

__PACKAGE__ -> add_columns(@ro_columns, @rw_columns);

package Quitz::Core;
use warnings;
use strict;
no strict "refs";

use base qw/ DBIx::Class::Schema Class::Accessor /;
use vars qw/ $AUTOLOAD @map_ok /;

use Exception::Class::TryCatch;

=head1 NAME

Quitz::Core - Extendable core of a quiz system

=head1 SYNOPSIS

    use Quitz::Core;

    my $core = new Quitz::Core
    (
        -ConnectInfo =>
        {
            'dsn' => 'dbi:Pg:dbname=quitz',
            username => 'quitz',
            password => 'quitz',
            storage_params =>
            {
                RaiseError => 1,
                on_connect_do => [ 'SET search_path TO quitz, public' ]
            }
        },
        -Credentials => { username => 'ail', password => 'ail' },
    );
	# TO DO: Example code

=cut

use Quitz::Core::Exceptions;
use Quitz::Core::AccessToken;
#use Quitz::Core::DataAccess;

our $VERSION = '0.01';

our @classes = qw/ User Category Question Answer Content ACL /;

__PACKAGE__ -> load_classes(@classes);

Quitz::Core::Category -> belongs_to(parent =>  __PACKAGE__ . '::Category', 'parent_id');
Quitz::Core::Category -> belongs_to(owner => __PACKAGE__ . '::User', 'owner');
Quitz::Core::Category -> has_many(subcategories => __PACKAGE__ . '::Category', 'parent_id');
Quitz::Core::Category -> has_many(questions => __PACKAGE__ . '::Question', 'category_id');
Quitz::Core::Question -> has_many(answers => __PACKAGE__ . '::Answer', 'question_id');
Quitz::Core::Question -> belongs_to(content => __PACKAGE__ . '::Content', 'content_id');
Quitz::Core::Answer -> belongs_to(content => __PACKAGE__ . '::Content', 'content_id');
Quitz::Core::User -> has_many(acl => __PACKAGE__ . '::ACL', 'user_id');

sub _connect_schema
{
	my ($self, $connect_info) = @_;
	my @params;
	throw Quitz::Core::EInvalidParameters( error => "One must pass connect_info hashref to Quitz::Core::new" )
		unless ref($connect_info) eq 'HASH';
	if ($connect_info -> {dbh})
	{
		@params = (sub { return $connect_info -> {dbh} } );
	}
	elsif ($connect_info -> {dsn})
	{
		@params = ($connect_info -> {dsn}, $connect_info -> {username} || '', $connect_info -> {password} || '');
	}
	else
	{
		throw Quitz::Core::EInvalidParameters( error => "One must specify either dbh or dsn in connect_info for Quitz::Core::new");
	}
	push @params, $connect_info -> {storage_params} if defined $connect_info -> {storage_params};
	$self -> clone -> connection(@params);
}

# mappings for $core->users to $core->resultset('User') and others

my %tables_map = ();

foreach (@classes)
{
	$tables_map{(__PACKAGE__.'::'.$_)->table()} = $_;
}

sub AUTOLOAD
{
	my $self = shift;
	my $method = $AUTOLOAD;
	
	$method =~ s/.*:://;
	return if $method =~ /^[A-Z]+$/;
	
	exists $tables_map{$method} and return __PACKAGE__->resultset($tables_map{$method});
	
	# Maybe throw an exception when a missing method is called?
	return;
}

=head1 METHODS

=head2 new %parameters

=over 4

Constructs new Quitz::Core object. Parameters take the form of a hash with the following keys:

=over 2

=item -ConnectInfo

=over 2

MANDATORY. HASH.

Parameters of the database connection.

If it contains a "dbh" key, it's value is interpreted as data base
handle of class DBI. Otherwise, it must contain a "dsn" key and, optionally, "username" and "password", which are used
to construct new data base connection.

Finally, since Quitz::Core uses DBIx::Class, any value of "storage_params" shall be passed
as last argument to the storage driver (see L<DBIx::Class::Storage::DBI> for possible parameters).

=back

=item -Credentials

=over 2

OPTIONAL. HASH.

When given, it should contain "username" and "password". If the user exists and the password matches, Quitz::Core
will check this user's access privileges before performing any operation. Otherwise, an AuthenticationFailure
exception shall be thrown.

SUBJECT TO CHANGE: Note that if one DO NOT GIVE "credentials" AT ALL, Quitz::Core will act in "superuser" mode, i.e. all
operations will be permited. I hope I don't have to say explicitly how dangerous this is.

=back

=cut

sub new
{
	my ($this, %params) = @_;
	my $classref = ref $this || $this;
	my $self = bless {}, $classref;

	$self = $self -> _connect_schema($params{-ConnectInfo});
	$self -> {access_token} = new Quitz::Core::AccessToken($self, $params{-Credentials});
	$self -> filter_columns_rights(@classes);	
	return $self;
}

__PACKAGE__ -> mk_ro_accessors(qw( access_token ));

sub filter_columns_rights
{
        my ($self, @classes) = @_;
        my ($full_class_name, $real_column_sub);
        foreach my $class (@classes)
        {
                $full_class_name = __PACKAGE__.'::'.$class;                
                foreach my $column (@{$full_class_name.'::ro_columns'})
                {
                        $real_column_sub = $full_class_name->can($column) ? \&{$full_class_name.'::'.$column} : sub {};
                        *{$full_class_name.'::'.$column} =
                                sub
                                {
                                        my $args_count = @_;
                                        my $obj_ref = shift;

                                        # first argument is class name when called via -> so this assumes that a reader is called
                                        if ($self -> check_access_token_for($obj_ref, S_READ)) 
                                        { 
                                        	if ($args_count == 1) 
                                        	{
                                        		return &$real_column_sub; 
                                        	} 
                                        	else
                                        	{
                                        		throw Quitz::Core::EInvalidParameters( error => "Method is read-only" );	
                                        	}
                                        } 
                                        else
                                        { 
                                        	throw Quitz::Core::EAccessDenied( error => "Method is not accessible" );
                                        }
                                }
                }
                foreach my $column(@{$full_class_name.'::rw_columns'})
                {
                        $real_column_sub = $full_class_name->can($column) ? \&{$full_class_name.'::'.$column} : sub {};
                        *{$full_class_name.'::'.$column} =
                                sub
                                {
                                        my $args_count = @_;
                                        my $obj_ref = shift;

                                        # first argument is class name when called via -> so this assumes that a reader is called
                                        if ($self -> check_access_token_for($obj_ref, S_WRITE))
                                        { 
                                        	return &$real_column_sub;
                                        } 
                                        elsif  ($self -> check_access_token_for($obj_ref, S_READ))
                                        {
                                        	if ($args_count == 1) 
	                                        { 
	                                        	return &$real_column_sub;
	                                        }
	                                      	else
	                                      	{
	                                      		throw Quitz::Core::EInvalidParameters( error => "Method is read-only" ); 
	                                      	}	                                      	
                                        } 
                                        else
                                        {
                                        	throw Quitz::Core::EAccessDenied( error => "Method is not accessible" );
                                        }
                                }
                }
        }

}

sub check_access_token_for 
{
	# $class, $self->id, S_WRITE
	my $self = shift;
	my $obj_ref = shift;
	my $access = shift;

	# @classes = qw/ User Category Question Answer Content ACL /;		
	if ($obj_ref eq "Category") 
	{		
		return 	$self -> check_access_token_for_category($obj_ref, $access);
	}
	if ($obj_ref eq "Question")
	{
		return 	$self -> check_access_token_for_question($obj_ref, $access);
	}
	if ($obj_ref eq "Answer")
	{				
		return 	$self -> check_access_token_for_answer($obj_ref, $access);
	}
	if ($obj_ref eq "Content")
	{			
		return 	$self -> check_access_token_for_content($obj_ref, $access);
	}
	
	#User and ACL are to be processed, now they will be fully accessible
	return 1;
	
}

sub check_access_token_for_category
{
	my ($self, $obj_ref, $access) = @_;

	if ($self -> {access_token} -> allow_on_cat ($obj_ref -> {id}, $access))
	{
		return 1;
	}
	return 0;
}

sub check_access_token_for_question
{
	my ($self, $obj_ref, $access) = @_;

	my $category_id = $obj_ref -> {category_id};		

	if ($self -> {access_token} -> allow_on_cat ($category_id, $access))
	{
		return 1;
	}
	return 0;
}

sub check_access_token_for_answer
{
	my ($self, $obj_ref, $access) = @_;
	
	my $question = $self -> resultset('Question') -> find($obj_ref -> {question_id} );

	my $category_id = $question -> {category_id};
	
	if ($self -> {access_token} -> allow_on_cat ($category_id, $access))
	{
		return 1;
	}
	return 0;
}

sub check_access_token_for_content
{
	my ($self, $obj_ref, $access) = @_;

	my ($question, $answer, $category_id);
	
	$question = $self -> resultset('Question') -> find (
		{
			category_id => $obj_ref -> {id},
		}
	);
	
	if ($question)
	{
		$category_id = $question -> {category_id};
		
		if ($self -> {access_token} -> allow_on_cat ($category_id, $access))
		{
			return 1;
		}
		return 0;	
	}
	else
	{
		$answer = $self -> resultset('Answer') -> find (
			{
				category_id => $obj_ref -> {id},
			}
		);
		if ($answer)
		{
			$category_id = $question -> {category_id};
		
			if ($self -> {access_token} -> allow_on_cat ($category_id, $access))
			{
				return 1;
			}
			return 0;	
		}
		else
		{
			#this content is not for a question or answer i.e. we can do whatever we want with it
			return 1;
		}
	}
}

=head1 COPYRIGHT & LICENSE

Copyright 2007 The Perl #2 Project Group, all rights reserved.

This program is released under the New BSD License. See LICENSE for details.

=cut

1;
